unit frm1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, core, vm, TntStdCtrls, ExtCtrls;
type
  Ttestfrm = class(TForm)
    PanelBottom: TPanel;
    enterinput: TTntButton;
    Splitter1: TSplitter;
    Panel2: TPanel;
    dstack: TListBox;
    Label1: TLabel;
    Panel1: TPanel;
    Label2: TLabel;
    output: TTntMemo;
    labeltoken: TLabel;
    ListBox1: TListBox;
    Label5: TLabel;
    token: TListBox;
    Label3: TLabel;
    input: TTntComboBox;
    stepwise: TTntButton;
    debug: TCheckBox;
    labelIP: TLabel;
    wordname: TLabel;
    ip: TListBox;
    procedure enterinputClick(Sender: TObject);
    procedure inputKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure outputKeyPress(Sender: TObject; var Key: Char);
    procedure debugClick(Sender: TObject);
  private
    { Private declarations }
  public
    procedure updatestatus;  
    { Public declarations }
  end;
const
  StackEmpty=$99999999;
var
  testfrm: Ttestfrm;
  forthengine: TKsanaForthVM;

implementation

{$R *.dfm}

procedure consoleinputcheck(vm:Tksanaforthvm);
begin
  application.ProcessMessages;
end;
procedure consoleztype(vm:Tksanaforthvm;s:pchar);
begin
  if testfrm=nil then exit;
  testfrm.output.Lines[testfrm.output.lines.count-1]:=
    testfrm.output.Lines[testfrm.output.lines.count-1]+s;
end;


procedure consoleemit(vm:Tksanaforthvm;c:char);
begin
  if testfrm=nil then exit;
  if c=#13 then begin
    testfrm.output.Lines.add('');
  end else begin
    testfrm.output.Lines[testfrm.output.lines.count-1]:=
      testfrm.output.Lines[testfrm.output.lines.count-1]+c;
  end;
end;

procedure Ttestfrm.updatestatus;
var i,n:integer;
begin
  dstack.clear; i:=forthengine.sp;
  if i>stackDepth then begin
    forthengine.error(' data stack overflow');
  end else if i<0 then begin
    dstack.items.add('==empty=='); inc(i);
    if i<0 then forthengine.error(' data stack underflow');
  end else begin
    n:=10;
    while i>=0 do begin
      dstack.Items.add(format('%x',[forthengine.dstack[i and $FF]]) );
      dec(i); dec(n);
      if n<=0 then begin
        if i>=0 then
          dstack.items.add('...');
        break;
      end;
    end;
  end;
end;

procedure Ttestfrm.enterinputClick(Sender: TObject);
var s:string;
begin s:=input.text;
      forthengine.appendoutput('  '+s); forthengine.cr;
      if debug.Checked then begin
        stepwise.Visible:=true;
        wordname.Visible:=true;
        token.Visible:=true;
        labeltoken.Visible:=true;
        ip.Visible:=true;
        labelip.Visible:=true;
      end;
      forthengine.eval(s);
      if forthengine.aborting then exit;
      input.Items.Insert(0,s);
      input.text:=''; updatestatus;
end;

procedure Ttestfrm.inputKeyPress(Sender: TObject; var Key: Char);
begin if key=#13 then enterinput.Click
 else if key=#27  then
   forthengine.esc:=1;
end;

procedure Ttestfrm.FormCreate(Sender: TObject);
begin forthengine:=TKsanaForthVM.create;
      forthengine.tickinputcheck:= consoleinputcheck;
      forthengine.tickztype := consoleztype;
      forthengine.tickemit := consoleemit;
      forthengine.reset;
      if forthengine.fence=0 then
        forthengine.fence:=forthengine.lastwordcfa;
      forthengine.reload;
      updatestatus;
end;

procedure Ttestfrm.FormDestroy(Sender: TObject);
begin forthengine.free;
end;

procedure Ttestfrm.outputKeyPress(Sender: TObject; var Key: Char);
begin
  if key>=#32 then begin
    input.SetFocus;
    inputKeyPress(Sender,Key); key:=#0; exit;
  end;
  if key<>#3 then key:=#0;
end;

procedure Ttestfrm.debugClick(Sender: TObject);
begin
  if not debug.Checked then begin
    stepwise.Visible:=false;
    wordname.Visible:=false;
    token.Visible:=false;
    labeltoken.Visible:=false;
    ip.Visible:=false;
    labelip.Visible:=false;
  end;
end;

end.
